unit http;

interface

uses
  SysUtils,
  Classes, blcksock, synsock,
  Synautil,
  ComCtrls,
  Contnrs,
  ServerActions;

type
  TSocketEvent = procedure(AIp, AOperation, AFile: string) of object;

  TDllList = class(TList)
  public
    procedure BeforeDispatch(var ADirectory, AUri, AOutPut: string;
      AHeaders: TStrings; var AResultType: Byte; ASocket: TTCPBlockSocket);
    procedure DrawPanels(APageControl: TPageControl);
    constructor Create;
    destructor Destroy; override;
  end;

  TTCPHttpDaemon = class(TThread)
  private
    Sock:TTCPBlockSocket;
    FPort: string;
    FDirectory: string;
    FSocketEvent: TSocketEvent;
    FDllList: TDllList;
    FThreadList: TObjectList;
    function GetPort: string;
    procedure SetPort(const Value: string);
  public
    constructor Create;
    destructor Destroy; override;
    procedure Execute; override;
    procedure Suspend;
    property Port: string read GetPort write SetPort;
    property Directory: string read FDirectory write FDirectory;
    property OnSocketEvent: TSocketEvent read FSocketEvent write FSocketEvent;
    property DllList: TDllList read FDllList;
  end;

  TTCPHttpThrd = class(TThread)
  private
    Sock:TTCPBlockSocket;
    FActions: TServerActions;
    FDirectory: string;
    FSocketEvent: TSocketEvent;
    FOperation: string;
    FFile: string;
    FDllList: TDllList;
    FSize: Longint;
    procedure Uploading(ADataLength: LongInt);
  public
    Headers: TStringList;
    InputData, OutputData: TMemoryStream;
    constructor Create (hsock:tSocket; ADirectory: string;
      ASocketEvent: TSocketEvent; ADllList: TDllList);
    destructor Destroy; override;
    procedure Execute; override;
    procedure Sincronizar;
    function ProcessHttpRequest(Request, URI: string): integer;
  end;

implementation

uses
  Windows,
  Forms,
  StrUtils, Controls;

{ TTCPHttpDaemon }

Constructor TTCPHttpDaemon.Create;
begin
  inherited create(false);
  sock:=TTCPBlockSocket.create;
  FreeOnTerminate:=true;
  Priority:=tpNormal;
  FDllList := TDllList.Create;
  FThreadList := TObjectList.Create(False);
  Suspend;
end;

Destructor TTCPHttpDaemon.Destroy;
begin
  FThreadList.Free;
  FDllList.Free;
  Sock.free;
  Terminate;
end;

procedure TTCPHttpDaemon.Execute;
var
  ClientSock:TSocket;
begin
  with sock do
    begin
      CreateSocket;
      setLinger(true,10);
      bind('0.0.0.0',FPort);
      listen;
      repeat
        if terminated then break;
        if canread(250) then
          begin
            ClientSock:=accept;
            if lastError=0 then
            begin
              FThreadList.Add(
                TTCPHttpThrd.create(ClientSock, FDirectory, FSocketEvent, FDllList)
                );

            end;
          end;
      until false;
    end;
end;

function TTCPHttpDaemon.GetPort: string;
begin
  if FPort = '' then
    raise Exception.Create('Port can''t be empty');
  Result := FPort;
end;

procedure TTCPHttpDaemon.SetPort(const Value: string);
begin
  FPort := VAlue;
end;

procedure TTCPHttpDaemon.Suspend;
var
  I: Integer;
begin
  for I := FThreadList.Count - 1 downto 0 do
  begin
    TThread(FThreadList[I]).Terminate;
    FThreadList.Delete(I);
  end;
  inherited Suspend;
end;

{ TTCPHttpThrd }

constructor TTCPHttpThrd.Create(Hsock:TSocket; ADirectory: string;
  ASocketEvent: TSocketEvent; ADllList: TDllList);
begin
  inherited create(false);
  FDirectory := ADirectory;
  sock:=TTCPBlockSocket.create;
  Headers := TStringList.Create;
  InputData := TMemoryStream.Create;
  OutputData := TMemoryStream.Create;
  FActions := TServerActions.Create;
  Sock.socket:=HSock;
  FreeOnTerminate:=true;
  Priority:=tpHighest;
  FSocketEvent := ASocketEvent;
  FDllList := ADllList;
end;

destructor TTCPHttpThrd.Destroy;
begin
  Sock.free;
  Headers.Free;
  InputData.Free;
  OutputData.Free;
  FActions.Free;
//  Terminate;
  inherited Destroy;
end;

procedure TTCPHttpThrd.Execute;
var
  timeout: integer;
  s: string;
  method, uri, protocol: string;
  x, n: integer;
  resultcode: integer;
  lSendBuffer: TSendBuffer;
  lUpload: Boolean;
  lFileName: string;
  lBoundary: string;

const
  cBufLength = 2048;  

begin
  FOperation := 'Connecting...';
  Synchronize(Sincronizar);
  timeout := 12000;
  lUpload := False;
  //read request line
  s := sock.RecvString(timeout);
  if sock.lasterror <> 0 then
  begin
    writeln(sock.lasterror);
    Exit;
  end;
  if s = '' then
    Exit;
  method := fetch(s, ' ');
  if (s = '') or (method = '') then
    Exit;
  uri := fetch(s, ' ');
  if uri = '' then
    Exit;
  protocol := fetch(s, ' ');
  headers.Clear;
  FSize := -1;
  //read request headers
  if protocol <> '' then
  begin
    if pos('HTTP/', protocol) <> 1 then
      Exit;
    repeat
      s := sock.RecvString(Timeout);
      if sock.lasterror <> 0 then
        Exit;
      if s <> '' then
        Headers.add(s);
      if Pos('CONTENT-LENGTH:', Uppercase(s)) = 1 then
        FSize := StrToIntDef(SeparateRight(s, ' '), -1);
      if Pos('MULTIPART', UpperCase(s)) > 0 then
        lUpload := True;
    until s = '';
  end;
  //recv document...
  InputData.Clear;

  if FSize >= 0 then
  begin
    if lUpload then
    begin
      s := Sock.RecvTerminated(TimeOut, #13#10#13#10);
      lBoundary := Copy(s, 0, Pos(#13#10, s) - 1);
      lFileName := Copy(s, Pos('filename=', s) + 10, Length(s));
      lFileName := Copy(lFileName, 0, Pos(#13, lFileName) - 2);

      FOperation := 'Uploading...';
      FFile := lFileName;
      Synchronize(Sincronizar);

      (* Quito el path (esto aparece en IE) *)
      while Pos('\', lFileName) <> 0 do
        lFileName := Copy(lFileName, Pos('\', lFileName) + 1, length(lFileName));

      s := Sock.RecvTerminated(TimeOut, lBoundary, Uploading);
      InputData.SetSize(Length(s));
      InputData.WriteBuffer(s[1], Length(s));

      s := Sock.RecvTerminated(TimeOut, #13#10);
      s := Sock.RecvTerminated(TimeOut, #13#10);
      s := Sock.RecvTerminated(TimeOut, #13#10);

      InputData.SaveToFile(FDirectory + '\' + lFileName);
     end

    else
    begin
      InputData.SetSize(FSize);
      x := Sock.RecvBufferEx(InputData.Memory, FSize, Timeout);
      InputData.SetSize(x);
      s := Headers.Text;
      Headers.Clear;
      Headers.LoadFromStream(InputData);
      Headers.Text := s + #13 + Headers.Text;
    end;
    if sock.lasterror <> 0 then
      Exit;
  end;

  OutputData.Clear;
  ResultCode := ProcessHttpRequest(method, uri);
  sock.SendString('HTTP/1.0 ' + IntTostr(ResultCode) + CRLF);
  if protocol <> '' then
  begin
    headers.Add('Connection: close');
    headers.Add('Date: ' + Rfc822DateTime(now));
    headers.Add('Server: Sharer');
    headers.Add('');
    for n := 0 to headers.count - 1 do
      sock.sendstring(headers[n] + CRLF);
  end;
  if sock.lasterror <> 0 then
    Exit;
  if Pos('DOWNLOAD?', UpperCase(uri)) > 0 then
  begin
    FOperation := 'Downloading...';
    FFile := FDirectory + Copy(Uri, Pos('?', Uri) + 1, Length(uri) - (Pos('?', Uri)));
    FFile := AnsiReplaceStr(FFile, '/', '\');

    Synchronize(Sincronizar);
    FActions.FileStream.Position := 0;
    while FActions.FileStream.Position < FActions.FileStream.Size do
    begin
      lSendBuffer := FActions.GetFilePart;
      Sock.SendBuffer(@lSendBuffer, SizeOf(lSendBuffer));
    end;
  end
  else
    Sock.SendBuffer(OutputData.Memory, OutputData.Size);
  FOperation := '-1';
  Synchronize(Sincronizar);
end;

function TTCPHttpThrd.ProcessHttpRequest(Request, URI: string): integer;
var
  l: TStringlist;
  lOutPut: string;
  lResultType: byte;
begin
  result := 504;
  if (request = 'GET') or (request = 'POST') then
  begin
    try
      l := TStringList.Create;
      (* Default response *)
      l.Add('<html>');
      l.Add('<head></head>');
      l.Add('<body>');
      l.Add('Request Uri: ' + uri);
      l.Add('<br>');
      l.Add('Error!!!');
      l.Add('</body>');
      l.Add('</html>');
      l.SaveToStream(OutputData);
      Result := 200;
      lResultType := 255;

      (* Call beforedispatch event of each plugin *)
      FDllList.BeforeDispatch(FDirectory, URI, lOutPut, headers, lResultType, Sock);

      (* Call default behavior *)
      if lResultType = 255 then
        FActions.ExecUri(FDirectory, URI, lOutPut, headers, lResultType);

      if lResultType = 0 then
      begin
        OutPutData.Clear;
        OutPutData.Position := 0;
        l.Text := lOutPut;
        l.SaveToStream(OutputData);
      end
      else
      if lResultType = 1 then
      begin
        OutPutData.Clear;
        OutPutData.Position := 0;
        OutPutData.Write(lOutPut[1], Length(lOutPut));
      end;
    finally
      l.free;
    end;
  end;
end;

procedure TTCPHttpThrd.Sincronizar;
begin
  FSocketEvent(Sock.GetRemoteSinIP, FOperation, FFile);
end;

procedure TTCPHttpThrd.Uploading(ADataLength: LongInt);
begin
  //Sleep(1000);
  FOperation := 'Uploading...' + IntToStr(ADataLength);
  Synchronize(Sincronizar);
end;

{ TDllList }

procedure TDllList.BeforeDispatch(var ADirectory, AUri, AOutPut: string;
  AHeaders: TStrings; var AResultType: Byte; ASocket: TTCPBlockSocket);

type
  TBeforeDispatch = procedure (var ADirectory, AUri, AOutPut: string;
    AHeaders: TStrings; var AResultType: Byte; ASocket: TTCPBlockSocket); stdcall;
var
  I: Integer;
  lProc: TBeforeDispatch;
begin
  for I := 0 to Count - 1 do
  begin
    lProc := GetProcAddress(Cardinal(Items[I]), 'BeforeDispatch');
    if @lProc <> nil then
    begin
      lProc(ADirectory, AUri, AOutPut, AHeaders, AResultType, ASocket);
      if AResultType <> 255 then
        Break;
    end;
  end;
end;

constructor TDllList.Create;
var
  lRes: TSearchRec;
  lHandle: Cardinal;

begin
  inherited;
  (* Load Dll List *)
  if FindFirst(ExtractFilePath(ParamStr(0)) + '\*.dll', faAnyFile, lRes) = 0 then
  begin
    repeat
      if (lRes.Attr and faAnyFile) = lRes.Attr then
      begin
        if AnsiEndsStr('.dll', lRes.Name) then
        begin
          lHandle := LoadLibrary(PChar(lRes.Name));
          if lHandle <> 0 then
          begin
            if GetProcAddress(lHandle, 'InitFSPlugin') <> nil then
            begin
              (* Now I'm sure it's a FileSharer plugin *)
              Add(Pointer(lHandle));
            end
            else
              FreeLibrary(lHandle);
          end;
        end;
      end;
    until FindNext(lRes) <> 0;
    SysUtils.FindClose(lRes);
  end;
end;

destructor TDllList.Destroy;
begin
  while Count > 0 do
  begin
    FreeLibrary(Cardinal(Items[Count - 1]));
    Delete(Count - 1);
  end;

  inherited;
end;

procedure TDllList.DrawPanels(APageControl: TPageControl);
type
  TGetTab = function (ATabSheet: TTabSheet; AAppHandle: Cardinal): TFormClass; stdcall;
var
  I: Integer;
  lProc: TGetTab;
  lTabSheet: TTabSheet;
  lFormClass: TFormClass;
  lForm: TForm;

begin
  for I := 0 to Count - 1 do
  begin
    lProc := GetProcAddress(Cardinal(Items[I]), 'GetTab');
    if @lProc <> nil then
    begin
      (* Create a new TabSheet *)
      lTabSheet := TTabSheet.Create(APageControl.Owner);
      lTabSheet.PageControl := APageControl;
      lFormClass := lProc(lTabSheet, Application.Handle);
      lForm := lFormClass.Create(Application);
      with lForm do
      begin
        Controls[0].Parent := lTabSheet;
      end;
    end;
  end;
end;

end.
